home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / comp / assembler / mini.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  13.0 KB  |  297 lines
  1. (herald (assembler mini t 0)
  2.         (env t (assembler as_open) (assembler mark) (assembler ib)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Implements Szymanski's algorithm for span dependent instruction 
  28. ;;; computation.  April 1978, CACM, pp300-308.
  29.  
  30. (define (minimize-displacements sdfs)
  31.     (receive (first last) (initialize-sdfs sdfs)
  32.       (compute-sdf-widths sdfs first last)))
  33.  
  34. (define (fixup-labels ibv sdfs m-addrs m-sdf-numbers)
  35.     (let ((adjs (compute-adjustments sdfs)))
  36.       (fixup-ibs ibv adjs sdfs)
  37.       (adjust-adjustments-for-alignments adjs sdfs)
  38.       (fixup-marks m-addrs m-sdf-numbers adjs) 
  39.                                                    
  40.       ;; womp final width and displacement into the fg
  41.       (walk-vector (lambda (sdf) 
  42.                      (cond ((not (empty? (sdf-span sdf)))
  43.                             (set (vref (sdf-vars sdf) (car (sdf-indices sdf)))
  44.                                  (sdf-width sdf))
  45.                             (set (vref (sdf-vars sdf) (cdr (sdf-indices sdf)))
  46.                                  (sdf-span sdf)))))
  47.                    sdfs)
  48.  
  49.       ;; return maximum adjustment (amount of increase in output size)
  50.       (let ((last-adj-i (fx- (vector-length adjs) 1)))
  51.          (if (fx< last-adj-i 0) 
  52.              0 
  53.              (vref adjs last-adj-i)))
  54.       ))
  55.  
  56. ;;; The data structures have been set up by 'count' and 'mark'
  57.  
  58. ;;; Initialize sdf structures:
  59. ;;;  - set 'next-dirty' slot of prev sdf to this sdf
  60. ;;;  - compute initial spans
  61. ;;;  - return the first and last dirty sdfs.
  62.  
  63. (define (initialize-sdfs sdfs)
  64.   (let ((sdfs-length (vector-length sdfs))
  65.         (first nil))
  66.     (iterate loop ((i 0) (prev nil))
  67.         (cond ((fx>= i sdfs-length) (return first prev))
  68.               (else
  69.                (let ((sdf (vref sdfs i)))
  70.                  (cond ((empty? (sdf-span sdf))   ; an alignment sdf
  71.                         (loop (fx+ i 1)  prev))
  72.                        (else                                     
  73.                         (initialize-span sdfs i sdf)
  74.                         (cond (prev (set (sdf-next-dirty prev) sdf))
  75.                               (else (set first sdf)))
  76.                         (loop (fx+ i 1) sdf)))))))))
  77.        
  78. ;;; Initialize a single sdf.  For a given sdf, add it to the crossers
  79. ;;; list of all sdfs that it crosses.
  80.  
  81. (define (initialize-span sdfs index sdf)
  82.   (let ((span (fx- (ib-address (sdf-label sdf)) 
  83.            (vref *mark-addresses* (sdf-mark sdf))))
  84.     (label-sdf# (ib-sdf-number (sdf-label sdf)))
  85.     (mark-sdf# (vref *mark-sdf-positions* (sdf-mark sdf))))
  86.     
  87.     (set (sdf-backwards? sdf) (fx>= mark-sdf# label-sdf#))
  88.     (set (sdf-span sdf) span)
  89.     
  90.     ;; consistency check
  91.     (cond ((or (and (fx> (sdf-span sdf) 0) (sdf-backwards? sdf))
  92.            (and (fx< (sdf-span sdf) 0) (not (sdf-backwards? sdf))))
  93.        (bug "inconsistent sdf ~s ~%" sdf)))
  94.     
  95.     (let ((dest (ib-sdf-number (sdf-label sdf))))
  96.       (receive (start end) 
  97.            (cond ((fx> dest index) (return (fx+ index 1) dest)) ;forward
  98.              (else (return dest index)))
  99.     (do ((i start (fx+ i 1)))
  100.         ((fx>= i end) sdf)
  101.       (push (sdf-crossers (vref sdfs i)) sdf))))
  102.     (set (sdf-width sdf) (sdf-first-width sdf))))
  103.  
  104. ;;; Main loop for computing widths.
  105. ;;; Take next sdf off list of (possibly) dirty sdfs.  If the width
  106. ;;; of the sdf is big enough to hold its current value, mark it clean;
  107. ;;; otherwise, change the width, mark sdfs that cross this one dirty,
  108. ;;; and then mark this one clean.
  109.  
  110. (define (compute-sdf-widths sdfs next last)
  111.    (iterate loop ((next next) (last last) (clean-i 0) (dirty-i 0))
  112.       (cond ((null? next) (cons clean-i dirty-i))   ; only informational
  113.             (else
  114.              (let* ((sdf next)
  115.                     (cur-w (sdf-width sdf)))
  116.                (receive (new-w maybe-new-span)
  117.                         ((sdf-selector sdf) cur-w (sdf-span sdf))
  118.                  ;; width changed?
  119.                  (cond ((fx> new-w cur-w) 
  120.                         (set (sdf-width sdf) new-w)
  121.                         ;; if width didn't change, span shouldn't change.
  122.                         (set (sdf-span sdf) maybe-new-span)
  123.                         (let ((new-last (dirty-crossers sdf (fx- new-w cur-w) last)))
  124.                            (loop (swap (sdf-next-dirty next) 0) 
  125.                                  new-last
  126.                                  (fx+ dirty-i 1)
  127.                                  clean-i)))
  128.                        (else
  129.                         (loop (swap (sdf-next-dirty next) 0) 
  130.                               last 
  131.                               dirty-i
  132.                               (fx+ clean-i 1))))
  133.                  )))))) 
  134.                  
  135. ;;; Utility for adjusting spans in all sdfs that span an sdf that has changed.
  136.  
  137. (define (dirty-crossers sdf delta current-last)
  138.   ;; list affected sdf's as dirty
  139.   (iterate set-dirty ((dirts (sdf-crossers sdf))
  140.               (new-last current-last))
  141.     (cond ((null? dirts) new-last)
  142.       (else
  143.        (modify (sdf-span (car dirts))
  144.            (lambda (s)     
  145.              (cond ((sdf-backwards? (car dirts)) (fx- s delta))
  146.                (else (fx+ s delta))) ))
  147.        (cond ;; was clean?
  148.         ((eq? 0 (sdf-next-dirty (car dirts))) 
  149.          (set (sdf-next-dirty new-last) (car dirts))
  150.          (set (sdf-next-dirty (car dirts)) nil)
  151.          (set-dirty (cdr dirts) (car dirts)))
  152.         ;; already dirty
  153.         (else  
  154.          (set-dirty (cdr dirts) new-last)))))))
  155.                                   
  156. ;;; Alignment adjustments happen at the end, and are not subjected
  157. ;;; to minimization.
  158.  
  159. (define (adjust-align-crossers sdf delta)
  160.   (let ((xers (sdf-crossers sdf)))
  161.     (if (not (empty? (sdf-span sdf))) (error "non-alignment sdf"))
  162.     (do ((xers xers (cdr xers)))
  163.         ((null? xers) nil)
  164.       (modify (sdf-span (car xers))
  165.          (lambda (s) 
  166.              (cond ((fx< s 0) (fx- s delta))
  167.                    ((fx> s 0) (fx+ s delta))
  168.                    (else (error "zero span 2"))))))))
  169.  
  170. ;;; After the sdf withs have been computed, we have to go back and adjust all 
  171. ;;; the label (and mark) address. Some addresses will have to be adjusted for 
  172. ;;; alignment. 'mark' inserted the maximum possible fill for alignment,
  173. ;;; and now we remove whatever is necessary.  Spans of sdf's that cross the
  174. ;;; alignments must be adjusted.
  175.                                                                  
  176. ;;; Compute adjustments table: eg, a label is preceded by 6 sdfs, so the 6th 
  177. ;;; element of this table will give the amount to adjust the label by.
  178. ;;; This leaves the 0th slot as a dummy (this is a feature).
  179.  
  180. (define (compute-adjustments sdfs)
  181.   (let* ((sdfs-length (vector-length sdfs))
  182.          (adj-length (fx+ sdfs-length 1))
  183.          (adjustments (make-vector adj-length)))
  184.     (set (vref adjustments 0) 0)
  185.     (iterate loop ((i 0) (accum-adjustment 0))
  186.       (cond ((fx>= i sdfs-length) adjustments)
  187.             (else
  188.               (let ((sdf (vref sdfs i)))             
  189.                 (cond ;; align sdfs don't count
  190.                       ((empty? (sdf-span sdf))
  191.                        (set (vref adjustments (fx+ i 1)) accum-adjustment)
  192.                        (loop (fx+ i 1) accum-adjustment))
  193.                       (else
  194.                        (let ((adj (fx+ accum-adjustment
  195.                                        (fx- (sdf-width sdf)
  196.                                             (sdf-first-width sdf)))))
  197.                          (set (vref adjustments (fx+ i 1)) adj)
  198.                          (loop (fx+ i 1) adj))))))))))
  199.  
  200. ;;; Apply the adjustments to the labels (IBs).  Align each
  201. ;;; after adjustment, and accumulate the adjustments made for alignment.
  202.  
  203. ;; Hacko alignment stuff.
  204.  
  205.   ;;; M is one less than multiple being align to.  The multiple must be
  206.   ;;; a power of 2.  So, to do quadword alignment, M is 7
  207.  
  208.   ;;; Except that we do everything in terms of bits, not bytes, so M is 63
  209.  
  210.   (define-integrable (as-align lc m)
  211.     (fixnum-logand (fx+ lc m) (fixnum-lognot m)))
  212.  
  213.   ;;; OFFSET is number of units past a boundry (as determined my M)
  214.  
  215.   (define-integrable (offset-align lc m offset)
  216.     (cond (offset 
  217.            (fx+ offset (as-align (fx- lc offset) m)))
  218.           (else
  219.            (as-align lc m))))
  220.                                                        
  221. ;;; The goal here is to set the address of each IB to the corrected
  222. ;;; value.  Ignoring alignments, this is straigtforward - just add the
  223. ;;; amount from the appropriate slot in the adjustments table.  If
  224. ;;; we do have to deal with alignment,  we compute that amount
  225. ;;; of shrinkage, record it in the alignment sdf, and add the shrinkage
  226. ;;; to the accumulating 'align-error'
  227.  
  228. ;;; [side note: some sdfs are in the vector of sdfs only to indicate that an
  229. ;;;  alignment happens at that point.  When we adjust an ib by reducing the 
  230. ;;;  number of alignment bytes preceeding it, we record the number of
  231. ;;;  bytes eliminated in the alignment sdf width field. ]
  232.  
  233. ;;; The only reason for recording the alignment shrinkage in the alignment
  234. ;;; sdfs, is that we must fix up the mark addresses also.  It is not
  235. ;;; possible to fixup the adjustments table as you go along, because
  236. ;;; you are iterating across the ibs, not the adjustments.
  237. ;;; So instead, we save the shrinks, and them apply them all at once
  238. ;;; to the adjustments vector by calling 'adjust-adjustments-for-alignments.'
  239. ;;; The new adjustments are applied to the marks by calling 'fixup-marks.'
  240.  
  241. (define (fixup-ibs ibv adj's sdfs)
  242.   (let ((ibv-length (vector-length ibv)))
  243.     (iterate loop ((i 0) (align-error 0))  ; accumulated alignment adj's
  244.        (cond ((fx>= i ibv-length) 'done)
  245.              (else
  246.               (let* ((ib (vref ibv i))
  247.                      (sdf# (ib-sdf-number ib))
  248.                      (ib-fix (fx+ align-error (vref adj's sdf#)))
  249.                      (new-ib-addr (fx+ (ib-address ib) ib-fix))
  250.                      (a (ib-align ib)))
  251. ;                (format t "~&ib,sdf#,ib-fix,new-ib-add,error ~s~%" 
  252. ;                    (list ib sdf# ib-fix new-ib-addr align-error))
  253.                 (cond ((not a)
  254.                        (set (ib-address ib) new-ib-addr)
  255.                        (loop (fx+ i 1) align-error))
  256.                       (else
  257.                        (let* ((re-aligned (offset-align (fx- new-ib-addr (car a))
  258.                                                         (cadr a)
  259.                                                         (caddr a)))
  260.                               (shrink (fx- re-aligned new-ib-addr))
  261.                               (align-sdf (vref sdfs (fx- sdf# 1)))
  262.                               )
  263.                          (if (fx> shrink 0) (error "alignment caused increase"))
  264.                          (set (ib-align ib) (fx+ (car a) shrink))
  265.                          (set (ib-address ib) re-aligned)
  266.                          (set (sdf-width align-sdf) shrink)
  267.                          (adjust-align-crossers align-sdf shrink)
  268.                          (loop (fx+ i 1) (fx+ align-error shrink))
  269.                          )))))))))        
  270.  
  271.  
  272. (define (adjust-adjustments-for-alignments adjs sdfs)
  273.   (let ((sdfs-length (vector-length sdfs)))
  274.     (iterate loop ((i 0) (align-error 0))
  275.         ;; because indices info adjs are offset by 1, we can do the
  276.         ;; set here, but it is easier to think about if at the bottom
  277.         (modify (vref adjs i) (lambda (a) (fx+ align-error a)))
  278.         (cond ((fx>= i sdfs-length) 'done)     
  279.               (else
  280.                (let* ((sdf (vref sdfs i))
  281.                       (a (if (empty? (sdf-span sdf)) (sdf-width sdf) 0)))
  282.                  (loop (fx+ i 1) (fx+ align-error a))))))))
  283.  
  284.  
  285.  
  286. (define (fixup-marks m-addrs m-sdf-numbers adjs)
  287.   (if (fxn= (vref adjs 0) 0)
  288.       (error "dummy adjustment slot changed"))
  289.   (let ((len (vector-length m-addrs)))
  290.     (do ((i 0 (fx+ i 1)))             
  291.         ((fx>= i len) 'done)
  292.       (modify (vref m-addrs i) 
  293.               (lambda (ma) 
  294.                 (fx+ ma (vref adjs (vref m-sdf-numbers i))))))))
  295.  
  296.  
  297.